home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
WCTUNITS.ARJ
/
XCRT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-30
|
17KB
|
589 lines
unit xcrt;
{ Written by William C. Thompson (wct@po.cwru.edu) - 1991
Parts of this unit were taken from HTScreen, written by
Harold Thunem. }
{ If anyone has an idea for a procedure, please E-mail and I
will consider including it in my unit. It should be something
that you do often. }
(* Features to be added:
Another unit containing definitions for different musical tones *)
{ Designer's Notes:
1. This unit was written was with the goal of making tedious crt
routines much more bearable by modularizing the entire process.
Another goal is to make the routines very fast by directly
affecting memory. Consequently, much of the error checking has
been left out. The user is responsible for error checking his
own code. In many cases this proves to give the user more
control, and there is little or no overhead if the code was
written with some care. For example, many times a rectangle
is defined by (x1,y1) & (x2,y2) which represent the upper-left
and lower-right corners, respectively. If x1>x2 or y1>y2 the
call is often ignored.
2. When setting foreground colors, you can set the blink constant
by adding 128 (pre-defined as 'blink') to the foreground color.
3. As yet, this unit is only designed to handle screens with
80 columns. Including checking for 40 columns would slow
down the procedures which are intended to be very fast.
A program using 40 columns could easily borrow the ideas
used in this unit. I have confirmed that they do work for
43/50 rows. Many don't work for 40 columns.
4. All window-like procedures are in absolute coordinates. Once
again, it up to the user to maintain relative coordinates
somehow (it is not very difficult) because that would slow down
the routines for other uses.
5. My apologies for my somewhat abnormal style of indentation, but
at least it is consistent (unlike some other code I have seen).
You may also notice that I avoid white spaces and capitalization
with a passion. It seems very silly to worry about how many
spaces I have put between variables, so I don't put any unless
absolutely necessary. I do try to keep my commenting neat, when
convenient. }
interface
uses crt,dos,keydef;
const
blackbg=$00;
bluebg=$10;
greenbg=$20;
cyanbg=$30;
redbg=$40;
magentabg=$50;
brownbg=$60;
lightgraybg=$70;
{ Setting the text color and background color at the same time can
be very tedious. You have to say TextColor(X) and TextBackGround(Y),
which is much too much typing. You can also be clever and set
TextAttr:=Y*16+X, which is a pain. This can be made simpler by
setting TextAttr:=YBG+X, which sets the background color at the
same with a minimum of typing. It also lets you avoid trying to
set background colors to 8-15, something that I have tried often.
More importantly, it makes it clearer to see what is happening.
For example, instead of
TextColor(White); TextBackGround(Cyan) or TextAttr:=Cyan*16+White,
much simpler would be
TextAttr:=CyanBG+White.
If you wish to set only the background or foreground color (but
not both), you can still use TextColor and TextBackGround. }
{ Text fonts, 25 or 43/50 rows }
ega43font=1;
normalfont=2;
{ border constants }
noborder=0;
singleborder=1;
doubleborder=2;
dtopsside=3;
stopdside=4;
{ textline constants }
thinhoriz=0;
thinvert=1;
thickhoriz=2;
thickvert=3;
type
screenpt=^screen;
screen=array[0..3999] of word;
{ This is a maximum size for a screen - 80 columns * 50 rows = 4000.
The maximum space required would then be 8000 bytes. }
block=record
rows,cols: word;
sp: screenpt
end;
getoneofstring=string[120];
writexystring=string[80];
var
badkeybeep: boolean; { beep when a bad is pressed? }
badkeyhz: word; { sound to emit for bad key }
badkeydur: word; { duration of bad key beep }
goodkeybeep: boolean; { beep when a good key is pressed }
goodkeyhz: word; { sound to emit for good key }
goodkeydur: word; { duration of good key beep }
cursorinitial, cursoroff, cursorunderline,
cursorhalfblock, cursorblock: word; { cursor settings }
preserveattr: boolean;
{ If preserveattr=true, putch will preserve the attribute settings
for a location on the screen. If preserveattr=false (default),
it will change the color attributes to the setting held in
textattr. }
crtrows, { Number of rows }
crtcols, { Number of columns }
videomode:byte; { Video-mode }
procedure beep(hz,dur: word);
function getch(x,y: byte):char;
function getattr(x,y: byte):byte;
procedure putch(x,y: byte; c: char);
procedure putattr(x,y:byte; attr:byte);
function shadowattr(attr:byte):byte;
procedure writexy(x,y: byte; s: writexystring);
procedure rightjust(x,y: byte; s: writexystring);
procedure centerjust(x,y:byte; s:writexystring);
procedure textbox(x1,y1,x2,y2: word; border:byte);
procedure textline(startat,endat,c:word; attr:byte);
procedure colorblock(x1,y1,x2,y2: word; c:byte);
procedure fillblock(x1,y1,x2,y2:word; ch:char);
procedure shadowblock(x1,y1,x2,y2:word);
procedure attrblock(x1,y1,x2,y2:word; attr:byte);
procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
procedure explodeblock(x1,y1,x2,y2:byte);
function readallkeys:char;
function yesorno:char;
function getoneof(s:getoneofstring):char;
function getcursor:word;
procedure setcursor(curs:word);
procedure savewindow(x1,y1,x2,y2: word; var w: block);
procedure killwindow(var w:block);
procedure recallwindow(x1,y1:word; var w: block);
function getfont:byte;
procedure setfont(font:byte);
function getvideomode:byte;
procedure setvideomode(mode:byte);
procedure xcrtinit;
implementation
const
borders:array[0..4] of string[6]=(' ',
'┌─┐│┘└',
'╔═╗║╝╚',
'╒═╕│╛╘',
'╓─╖║╜╙');
var
regs: registers;
videoseg: word; { Video segment address }
procedure beep(hz,dur: word);
begin
sound(hz);
delay(dur);
nosound
end;
function getch(x,y: byte):char;
{ returns character at absolute position (x,y) through memory
The error checking has been removed to speed up function }
begin
getch:=char(mem[videoseg:(160*y+2*x-162)]); { 2*80*(y-1)+2*(x-1) }
end;
function getattr(x,y: byte):byte;
{ returns color attribute at absolute position (x,y) through memory
The error checking has been removed to speed up function }
begin
getattr:=mem[videoseg:(160*y+2*x-161)]; { 2*80*(y-1)+2*(x-1)+1 }
end;
procedure putch(x,y: byte; c: char);
{ QUICKLY writes c to absolute position (x,y) through memory
This is at least 10 times faster than a gotoxy(x,y), write(c)
Another bonus is that the cursor doesn't move.
The error checking has been removed }
begin
if not preserveattr then
memw[videoseg:(160*y+2*x-162)]:=textattr shl 8+ord(c)
else mem[videoseg:(160*y+2*x-162)]:=ord(c)
end;
procedure putattr(x,y,attr: byte);
{ Directly change the color attributes of char at absolute screen (x,y) }
begin
mem[videoseg:(160*y+2*x-161)]:=attr
end;
function shadowattr(attr:byte):byte;
{ Returns an appropriate shadow attribute. First it masks out the
upper four bits (background of shadow is always black) as well as
the 3rd bit (a shadow should be a dark color). Unfortunately,
if the text color is black, you can't see it, so there is a
special case for that (sets it to lightgray). }
var
temp: byte;
begin
temp:=attr and $07;
if temp=black then shadowattr:=lightgray
else shadowattr:=temp
end;
procedure writexy(x,y: byte; s: writexystring);
{ Writes string s at absolute (x,y) - left justified }
var
i: byte;
begin
for i:=1 to length(s) do putch(x+i-1,y,s[i])
end;
procedure rightjust(x,y: byte; s: writexystring);
{ Right justifies string s at absolute (x,y) }
begin
writexy(x-length(s)+1,y,s)
end;
procedure centerjust(x,y:byte; s:writexystring);
{ Centers string s about x at y }
begin
writexy(x-length(s) div 2,y,s)
end;
procedure textbox(x1,y1,x2,y2: word; border:byte);
{ draws a text box defined by the two points }
var
i: integer;
ch: char;
s: string[6];
begin
if not border in [1..4] then exit;
s:=borders[border];
{ handle special cases first, x1=x2 or y1=y2 }
if x1=x2 then { straight line down }
for i:=y1 to y2 do putch(x1,i,s[4])
else if y1=y2 then { straight line across }
for i:=x1 to x2 do putch(i,y1,s[2])
else if (x1<x2) and (y1<y2) then begin
{ draw corners }
putch(x1,y1,s[1]);
putch(x1,y2,s[6]);
putch(x2,y2,s[5]);
putch(x2,y1,s[3]);
{ draw lines }
for i:=y1+1 to y2-1 do putch(x1,i,s[4]);
for i:=y1+1 to y2-1 do putch(x2,i,s[4]);
for i:=x1+1 to x2-1 do begin
putch(i,y1,s[2]);
putch(i,y2,s[2]);
end
end
end;
procedure textline(startat,endat,c:word; attr:byte);
{ The first two parameters are the starting and ending values
of the range of the line, vertical or horizontal. The third
is the constant value. i.e. horiz => (x1,x2,y), vert => (y1,y2,x) }
var
i: integer;
begin
if attr mod 2=0 then begin
gotoxy(startat,c);
if attr div 2=0 then for i:=startat to endat do putch(i,c,'─')
else for i:=startat to endat do putch(i,c,'═')
end
else
if attr div 2=0 then for i:=startat to endat do putch(c,i,'│')
else for i:=startat to endat do putch(c,i,'║')
end;
procedure colorblock(x1,y1,x2,y2:word; c:byte);
{ Fills block with █ in the specified color - preserves color settings.
Can conflict with shadowing - ShadowBlock changes the background
color of the shadowed region to black and foreground colors to
the approriate shadowed color. Therefore, if you shadow a region
containing █'s, it will not make them black. Make sense? If you
intend to use shadowing, you are better off making regions with
background colors and using FillBlock. In addition, if text is to
be put in the area, the text must have an appropriate background
color. ColorBlock should basically only be used for cosmetic
purposes (such as filling in the sides of the screen), as it
conflicts with so many other routines. }
var
i,j:byte;
sc: byte;
begin
sc:=textattr;
textcolor(c);
for i:=x1 to x2 do
for j:=y1 to y2 do putch(i,j,'█');
textattr:=sc
end;
procedure fillblock(x1,y1,x2,y2:word; ch:char);
{ Fills a block with the specified character using the current
color settings. If you want to empty a region, set the colors
by setting (as an example) TextAttr=CyanBG+White (cyan background
with a white foreground) and the fill the block with ' '. }
var
i,j:byte;
begin
for i:=x1 to x2 do
for j:=y1 to y2 do putch(i,j,ch)
end;
procedure shadowblock(x1,y1,x2,y2:word);
{ Shadows a block using the appropriate shadowing
for each character's color attribute }
var
i,j:byte;
begin
for i:=x1 to x2 do
for j:=y1 to y2 do putattr(i,j,shadowattr(getattr(i,j)))
end;
procedure attrblock(x1,y1,x2,y2:word; attr:byte);
{ Changes the foreground and background colors within the
specified rectangle. This is different from shadowblock,
which uses the appropriate shadowing for a color attribute. }
var
i,j: byte;
begin
for i:=x1 to x2 do
for j:=y1 to y2 do putattr(i,j,attr);
end;
procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
{ Scrolls a block up and leaves the wakeattr color in the empty row }
begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$06;
regs.al:=$01;
regs.bh:=wakeattr;
regs.ch:=y1-1;
regs.cl:=x1-1;
regs.dh:=y2-1;
regs.dl:=x2-1;
intr($10,regs);
end;
procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
{ Scrolls a block down and leaves the wakeattr color in the empty row }
begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$07;
regs.al:=$01;
regs.bh:=wakeattr;
regs.ch:=y1-1;
regs.cl:=x1-1;
regs.dh:=y2-1;
regs.dl:=x2-1;
intr($10,regs);
end;
procedure explodeblock(x1,y1,x2,y2:byte);
{ explodes a block }
var
i,r1,r2,c1,c2: byte;
mr,mc,dr,dc: real;
begin
dr:=(x2-x1+1)/11;
dc:=(y2-y1+1)/11;
mr:=(x1+x2+1)/2;
mc:=(y1+y2+1)/2;
for i:=1 to 5 do begin
r1:=trunc(mr-i*dr);
r2:=trunc(mr+i*dr);
c1:=trunc(mc-i*dc);
c2:=trunc(mc+i*dc);
fillblock(r1,c1,r2,c2,' ');
end;
fillblock(x1,y1,x2,y2,' ');
end;
function readallkeys:char;
{ This function correctly reads in a keypress and returns the
correct value for "other" keys. See the KEYDEF unit for what
each special key returns. Note: the function doesn't return
an actual character for special keys (F1-F10,etc.) - it is only
a character to represent the special key that was pressed. }
var
ch: char;
begin
ch:=readkey;
if ch=#0 then readallkeys:=transformedkey(readkey)
else readallkeys:=ch
end;
procedure badkeysound;
begin
beep(badkeyhz,badkeydur);
end;
procedure goodkeysound;
begin
beep(goodkeyhz,goodkeydur)
end;
function yesorno:char;
{ waits for the user to press 'y','Y','n','N' }
var
ch: char;
begin
repeat
ch:=upcase(readallkeys);
if not (ch in ['Y','N']) and badkeybeep then badkeysound
until ch in ['Y','N'];
yesorno:=ch;
if goodkeybeep then goodkeysound
end;
function getoneof(s:getoneofstring):char;
{ waits for the user to input a character contained in cs }
var
ch: char;
begin
repeat
ch:=readallkeys;
if badkeybeep and (pos(ch,s)<=0) then badkeysound
until pos(ch,s)>0;
getoneof:=ch;
if goodkeybeep then goodkeysound;
end;
function getcursor:word;
{ returns cursor size }
begin
getcursor:=(mem[$0040:$0060] shl 4)+mem[$0040:$0061];
end;
procedure setcursor(curs:word);
{ sets cursor size }
begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$01;
regs.ch:=curs mod 16;
regs.cl:=curs div 16;
intr($10,regs);
end;
procedure savewindow(x1,y1,x2,y2: word; var w: block);
{ This procedure saves a screen block. It is not intended to
open up a window, but can be used to store what is underneath
a window. (absolute coordinates) }
var
i,j: word;
size: word;
begin
with w do begin
rows:=0;
cols:=0;
if (x2<x1) and (y2<y1) then exit; { invalid window }
rows:=x2-x1+1;
cols:=y2-y1+1;
size:=rows*cols*2; { bytes required to store screen }
getmem(sp,size); { allocate sufficient space }
for i:=0 to rows-1 do
for j:=0 to cols-1 do
sp^[j*rows+i]:=memw[videoseg:(160*(j+y1)+2*(i+x1)-162)];
end
end;
procedure killwindow(var w:block);
{ Free space taken up by screen block (absolute coordinates) }
begin
with w do freemem(sp,rows*cols*2)
end;
procedure recallwindow(x1,y1:word; var w:block);
{ redraw window at (x1,y1) (absolute coordinates) }
var
i,j: word;
begin
with w do
for i:=0 to rows-1 do
for j:=0 to cols-1 do
memw[videoseg:(160*(j+y1)+2*(i+x1)-162)]:=sp^[j*rows+i]
end;
function getfont:byte;
{ gets the number of rows on the screen }
begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$11;
regs.al:=$30;
regs.bh:=$02;
intr($10,regs);
getfont:=regs.dl+1;
end;
procedure setfont(font:byte);
{ sets the number of rows on the screen:25 or 43/50 }
begin
if font=normalfont then begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$00;
regs.al:=videomode;
intr($10,regs);
crtrows:=25;
end
else begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$11;
regs.al:=$12;
regs.bh:=$00;
intr($10,regs);
crtrows:=getfont;
end;
end;
function getvideomode:byte;
{ Returns the Video mode }
begin
fillchar(regs,sizeof(regs),0);
regs.ah:=$0F;
intr($10,regs);
getvideomode:=regs.al;
end;
procedure setvideomode(mode:byte);
{ sets the video mode }
begin
if not mode in [$02,$03,$07] then exit;
fillchar(regs,sizeof(regs),0);
regs.ah:=$00;
regs.al:=mode;
intr($10,regs);
end;
procedure xcrtinit;
{ initializes some variables }
begin
{ initialize bad key settings }
badkeybeep:=false;
badkeyhz:=250;
badkeydur:=50;
{ initialize good key settings }
goodkeybeep:=false;
goodkeyhz:=150;
goodkeydur:=10;
preserveattr:=false;
{ initialize videomode }
videomode:=getvideomode;
if not videomode in [$02,$03,$07] then halt; { invalid video mode }
{ initialize cursor stuff }
cursorinitial:=getcursor;
crtcols:=80;
case videomode of
$02,$03:begin
cursorunderline:=118; { 6-7 }
cursorhalfblock:=116; { 4-7 }
cursorblock:=113; { 1-7 }
cursoroff:=1; { 0-1 }
videoseg:=$B800;
end;
$07:begin
cursorunderline:=203; { 11-12 }
cursorhalfblock:=198; { 6-12 }
cursorblock:=193; { 1-12 }
cursoroff:=1; { 0- 1 }
videoseg:=$B000;
end;
end;
crtrows:=getfont;
end;
begin
xcrtinit;
end.